
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real    temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      logical answer, Quit
      character ch

      call init
      call initio
      call initbs
      call initit
      call initsh
10    continue
      call clrscr
      Quit = .FALSE.
      print *, ' Enter'
      print *, ' <S> To Solve Heat Problem'
      print *, ' <P> To Plot Output to Disk or Screen'
      print *, ' <L> To List Numerical Data to Disk or Screen'
      print *, ' <Q> To Quit'
      call rdchar (Ch)
      IF (Ch .eq. 'S' .or. Ch .eq. 's') THEN
	 call SOLVE
      ELSE IF (Ch .eq. 'P' .or. Ch .eq. 'p') THEN
	 call PLOT
      ELSE IF (Ch .eq. 'L' .or. Ch .eq. 'l') THEN
	 call LIST
      ELSE IF (Ch .eq. 'Q' .or. Ch .eq. 'q') THEN
	 Quit = .TRUE.
      ELSE IF (Ch .eq. '|' .or. Ch .eq. '~') THEN
	 call wrtmsh
      ELSE
	 call WRONG
      END IF
      IF ( Quit .eqv. .FALSE. ) GO TO 10
      call ENDOPT (answer)
      IF (answer .eqv. .FALSE.) GO TO 10
      END

      SUBROUTINE SOLVE
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      integer iter
      logical answer

      IF (finis .eqv. .FALSE.) THEN 
	 call finopt(answer)
	 IF (answer .eqv. .TRUE.) finis = .TRUE.
      END IF
      call readin
      call initlz
      IF (maxit .eq. 0) return
      IF (finis .eqv. .TRUE.) THEN
	 iterno = 0
	 finis  = .FALSE.
      END IF
15    continue
      do 20 iter = 1, maxit
	 iterno = iterno + 1
	 call clrscr
	 print *,' Iteration step number ',iterno, '    of ',maxit
	 call itrate
	 IF ( bigres .lt. cnvrg ) THEN
	    finis = .TRUE.
	    call beep(2)
	    call clrscr
	    call wcvrg
	    Return
	 END IF
20    continue
30    continue
      finis = .FALSE.
      call beep(2)
      call clrscr
      call wncvrg
      call conopt (answer)
      IF (answer .eqv. .TRUE.) GO TO 15
      END

      SUBROUTINE readin
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      logical answer

      IF (finis .eqv. .FALSE.) THEN
	 call gtiter
	 return
      END IF
10    continue
      call clrscr
      call wrbas
      call writer
      call wrshp
      call okopt  (answer)
      IF (answer .eqv. .TRUE.) GO TO 90
      call gtbas
      call gtiter
      call gtshp
      GO TO 10
90    continue
      END 

      SUBROUTINE initlz
      intrinsic nint, min, max
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real intrnt, lowert, uppert, prcnt, mint, maxt
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,col,rowe,midcol
      real edget,incr,w

      IF (finis .eqv. .FALSE.) return
      call initts
      call initmp
      mint = min(lowert,uppert,intrnt)
      maxt = max(lowert,uppert,intrnt)
      midcol = (size+1)/2
5     continue
      GO TO (10,15,10) shape
      print *, ' Shape value = ',shape
10    continue
      call mkrect(1,1,size,vsize,els,ers)
      GO TO 20
15    continue
      call mkrnd (1,1,size,els,ers)
20    continue
      IF (solid .eqv. .TRUE.) GO TO 40
      GO TO (25,30,25)inshp
25    continue
      call mkrect(hthick,vthick,insize,ivsize,ils,irs)
      GO TO 35
30    continue
      call mkrnd (hthick,vthick,insize,ils,irs)
35    continue
40    continue
      call tstskw
      call mkwall
      do 50 col = tmpshp(1,els), midcol
	 temper(1,col) = uppert
	 temper(1,size-col+1) = uppert
50    continue   
      w     = vsize * (100 - prcnt) * .01
      rowe  = nint(w) 
      IF (rowe .lt. 2) THEN
	 rowe = 1
	 GO TO 61
      END IF
      incr  = (uppert - lowert)/rowe
      edget = uppert
      do 60 row = 2, rowe
	 edget = edget - incr
      do 55 col = tmpshp(row,els),midcol
	 temper(row,col) = edget
	 temper(row,size-col+1) = edget
55    continue
60    continue
61    continue
      do 70 row = rowe+1,vsize
      do 65 col = tmpshp(row,els),midcol
	 temper(row,col) = lowert
	 temper(row,size-col+1) = lowert
65    continue
70    continue
      IF (solid .eqv. .TRUE.) GO TO 90
      do 80 row = vthick,vthick+ivsize-1
      do 75 col = tmpshp(row,ils),tmpshp(row,irs)
	 temper(row,col) = intrnt
75    continue
80    continue
90    continue
      END

      SUBROUTINE itrate 
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real    temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,col,colm,midcol

      bigres = 0
      midcol = (size+1)/2
      IF (skewed .eqv. .TRUE.) GO TO 30
      do 20 row = 2,vsize-1
      do 10 col = tmpshp(row,wlb),midcol
	 call comput(row,col)
	 colm = size-col+1
	 temper(row,colm) = temper(row,col)
10    continue
20    continue
      return
30    continue
      do 50 row = 2,vsize-1
      do 40 col = tmpshp(row,wlb),midcol
	 call comput(row,col)
	 colm = size-col+1
	 call comput(row,colm)
40    continue  
50    continue
      END

      SUBROUTINE comput (row,col)                                         
      intrinsic max,abs
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      real tempt
      logical answer
      integer row,col

      call inwall(row,col,answer)
      IF (answer .eqv. .FALSE.) return
      tempt = (0.25 * accfac) *
     +        (temper(row+1,col) + temper(row-1,col) +
     +         temper(row,col+1) + temper(row,col-1)) +
     +        ((1.0 - accfac) * temper(row, col))
      bigres = max(bigres,abs(tempt-temper(row,col)))
      temper(row,col)=tempt
      END

      SUBROUTINE plot
      intrinsic abs, mod
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real intrnt, lowert, uppert, prcnt, mint, maxt
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row, col, index
      real tincr
      logical answer
      character*1 blank, letter(1:17)
	 parameter ( blank = ' ' )

      call initlt(letter)
      call ltropt(ltrltr)
      call gtioop(answer)
      IF (answer .eqv. .FALSE.) return
      tincr = abs(maxt-mint)/17
      call clrscr              
      lincnt = 0
      do 30 row = 1, vsize
	 call initln
      do 20 col = tmpshp(row,els),tmpshp(row,ers)
	 call onwall(row,col,answer)
	 IF (answer .eqv. .FALSE.) THEN
	    line(col) = blank
	 ELSE 
     +   IF (temper(row,col) .le. mint) THEN
	    index = 1
	    line(col) = letter(index)
	 ELSE 
     +   IF (temper(row,col) .ge. maxt) THEN
	    index = 17
	    line(col) = letter(index)
	 ELSE                              
	    index = ((temper(row,col)-mint)/tincr)+1.0
	    IF ((ltrltr .eqv. .FALSE.) .and. (mod(index,2) .eq. 0)) THEN
	       line(col) = blank
	    ELSE 
	       line(col) = letter(index)
	    END IF
	 END IF
20    continue
      IF (scrnop .eqv. .TRUE.) THEN
	  IF (lincnt .ge. 20) THEN
	     call conopt (answer)
	     IF (answer .eqv. .FALSE.) GO TO 50
	     call clrscr
	     lincnt = 0
	  END IF
	  lincnt = lincnt + 1
	  print '(1x,79a1)', line
      END IF
      IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.))
     +   write (iolog,'(1x,79a1)') line
30    continue
50    continue
      call wrltrs(letter,maxt,mint,tincr)
      IF (opened .eqv. .TRUE.) call cldisk
      END

      SUBROUTINE LIST 
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,rowb,rowe,col,colb,cole
      logical answer

      call rdlist
      call gtlmts(rowb,colb,rowe,cole)
      call gtioop (answer)
      IF (answer .eqv. .FALSE.) return
      IF (opened .eqv. .TRUE.) THEN
	 do 20 row = rowb,rowe
	 do 10 col = colb,cole
	    call onwall(row,col,answer)
	    IF (answer .eqv. .TRUE.) THEN
	       write (iolog,'(I3,I3,f11.5)') row, col, temper(row,col)
	    END IF
10       continue      
20       continue
      call cldisk
      END IF
      IF (scrnop .eqv. .TRUE.) THEN
	 call clrscr
	 lincnt = 0
	 do 70 row = rowb,rowe
	 do 60 col = colb,cole
	 IF (lincnt .ge. 20) THEN
	    call conopt (answer)
	    IF (answer .eqv. .FALSE.) GO TO 90
	    call clrscr
	    lincnt = 0
	 END IF
	 call onwall(row,col,answer)
	 IF (answer .eqv. .TRUE.) THEN
	    IF (lincnt .ge. 20) THEN
	       call conopt (answer)
	       IF (answer .eqv. .FALSE.) GO TO 90
	       call clrscr
	       lincnt = 0
	    END IF
	    lincnt = lincnt + 1
	    print *,' ',row,col,temper(row,col)
	 END IF
60       continue
70       continue
      END IF
90    continue
      IF (scrnop .eqv. .TRUE.) call prentr
      END

      SUBROUTINE OpDskI
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      character*50 filenm
      logical answer,unfmt

      unfmt = .FALSE.
      print *,' Opening Input File'
      GO TO 10      
      ENTRY OpDskO
      IF (diskop .eqv. .FALSE.) THEN
	 print *, ' Cannot open disk for output',
     +      ' if the disk option is not set.'
	 opened = .FALSE.
	 return
      END IF
      print *, ' W A R N I N G ! ! !   W A R N I N G ! ! !'
      print *, ' If the file already exists it WILL BE OVERWRITTEN!'
      call conopt(answer)
      IF (answer .eqv. .FALSE.) THEN
	 opened = .FALSE.
	 return
      END IF
      unfmt = .FALSE.
      print *,' Opening Output File'
      GO TO 10
      ENTRY OpDskU
      unfmt = .TRUE.
      print *,' Opening Unformatted File for Input or Output'
      GO TO 10
10    continue
      call clrscr
20    continue
      print *, ' Enter disk path and filename'
      call rdstr (filenm)
      print *, ' Is this the correct path and filename ', filenm
      call yesno(answer)
      IF (answer .eqv. .FALSE.) GO TO 20
      IF (unfmt .eqv. .TRUE.) THEN
	 open (UNIT=iolog, FILE=filenm, FORM='UNFORMATTED', ERR=30,
     +         STATUS='UNKNOWN')
      ELSE
	 open (UNIT=iolog, STATUS='UNKNOWN', FILE=filenm, ERR=30)
      END IF
      print *,' File ',filenm,' successfully opened.'
      opened = .TRUE.
      return
30    continue
      print *, ' Error opening disk file ', filenm
      opened = .FALSE.
      call tryopt (answer)
      IF (answer .eqv. .TRUE.) GO TO 20
      END

      SUBROUTINE ClDisk
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)

      IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
	 close(iolog)
	 call beep(1)
	 diskop = .FALSE.
	 opened = .FALSE.
      END IF
      END

      SUBROUTINE okopt (answer)  
	 logical answer
	 print *, ' Is everything all right?'
	 call yesno (answer)
	 END
      SUBROUTINE tryopt (answer) 
	 logical answer
	 print *, ' Do you wish to try it again?'
	 call yesno (answer)
	 END
      SUBROUTINE conopt (answer) 
	 logical answer
	 print *, ' Do you wish to continue?'
	 call yesno (answer)
	 END
      SUBROUTINE endopt (answer) 
	 logical answer
	 print *, ' Do you really wish to end all this?'
	 call yesno (answer)
	 END
      SUBROUTINE scropt (answer) 
	 logical answer
	 print *, ' Do you wish screen output?'
	 call yesno (answer)
	 END
      SUBROUTINE dskopt (answer) 
	 logical answer
	 print *, ' Do you wish disk output?'
	 call yesno (answer)
	 END
      SUBROUTINE ltropt (answer) 
	 logical answer
	 print *, ' Do you wish letter to letter plot?'
	 call yesno (answer)
	 END
      SUBROUTINE lstopt (answer) 
	 logical answer
	 print *, ' Do you wish to read the list data from disk?'
	 call yesno (answer)
	 END
      SUBROUTINE limopt (answer) 
	 logical answer
	 print *, ' Do you wish to list all of the values?'
	 call yesno (answer)
	 END
      SUBROUTINE solopt (answer) 
	 logical answer
	 print *, ' Is the shield solid?'
	 call yesno (answer)
	 END
      SUBROUTINE basopt (answer) 
	 logical answer
	 print *, ' Do you wish to modify the basic options?'
	 call yesno (answer)
	 END
      SUBROUTINE itropt (answer) 
	 logical answer
	 print *, ' Do you wish to modify the iteration control?'
	 call yesno (answer)
	 END
      SUBROUTINE shpopt (answer) 
	 logical answer
	 print *, ' Do you wish to modify the shield size or shape?'
	 call yesno (answer)
	 END
      SUBROUTINE finopt (answer) 
	 logical answer
	 print *, ' There is a solution still in progress.'
	 print *, ' Do you wish to end the previous solution?'
	 call yesno (answer)
	 END

      SUBROUTINE yesno(answer)
      logical answer
      character*1 ch
10    continue
      print *, ' Enter <Y> for yes, <N> for no.'
      call rdchar (Ch)
      IF ((ch .eq. 'Y') .or. (ch .eq. 'y')) THEN
	 answer = .TRUE.
      ELSE IF ((ch .eq. 'N') .or. (ch .eq. 'n')) THEN
	 answer = .FALSE.
      ELSE
	 call wrong
	 GO TO 10
      END IF
      END

      SUBROUTINE rdreal (r)
      real r
10    continue
      read (*,*,ERR=20) r
      return
20    print *, ' Invalid real number entered.  Please reenter value.'
      GO TO 10
      END
      SUBROUTINE rdint (i)
      integer i
10    continue
      read (*,*,ERR=20) i
      return
20    print *, ' Invalid integer entered.  Please reenter value.'
      GO TO 10
      END
      SUBROUTINE rdchar (c)
      character c
10    continue
      read (*,*,ERR=20) c
      return
20    print *, ' Invalid character entered.  All characters '
      print *, ' must begin and end with a single quote.  Please'
      print *, ' reenter the value.'
      GO TO 10
      END
      SUBROUTINE rdstr (s)
      character*50 s
10    continue
      read (*,*,ERR=20) s
      return
20    print *, ' Invalid character string entered.  All strings '
      print *, ' must begin and end with a single quote.  Please'
      print *, ' reenter the string.'
      GO TO 10
      END

      SUBROUTINE rdintr                                                      
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
	 print *, ' Enter internal temperature'
      call rdreal (intrnt)
      END
      SUBROUTINE rduppr                                                      
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
	 print *, ' Enter upper edge of shield temperature'
      call rdreal (uppert)
      END
      SUBROUTINE rdlowr                                                      
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      print *, ' Enter bottom of shield temperature'
      call rdreal (lowert)
      END
      SUBROUTINE rdpct                                                       
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      logical answer
10    continue
      print *, ' Enter percent of the shield kept at bottom temp'
      call rdreal (prcnt)
      IF ((prcnt .gt. 100) .or. (prcnt .lt. 0)) THEN
	 print *, ' The value must be between 0 and 100.'
	 call wrong
	 IF (answer .eqv. .TRUE.) GO TO 10
      END IF
      IF (prcnt .eq. 0) THEN
	 print *, ' Zero percent implies the bottom temperature has'
	 print *, ' no influence.  The lower shield temperature is set'
	 print *, ' equal to the upper shield temperature.'
	 lowert = uppert
	 return
      END IF
      IF (prcnt .eq. 100) THEN
	 print *,' One hundred percent implies the upper temperature'
	 print *,' has no influence.  The upper shield temperature is'
	 print *,' set equal to the lower shield temperature.'
	 uppert = lowert
	 return
      END IF
      END
      SUBROUTINE rdmxt                                                       
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
10    continue
      print *, ' Enter the maximum number of iterations per pass'
      call rdint (maxit)
      IF (maxit .lt. 0) THEN
	 print *, ' The number of iterations cannot be negative.'
	 GO TO 10
      END IF
      END
      SUBROUTINE rdaccf                                                      
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
10    continue
      print *, ' Enter the acceleration factor (normally 1.84).'
      print *, ' Small changes are recommended.'
      call rdreal (accfac)
      IF (accfac .lt. 1) THEN
	 print *, ' The acceleration factor cannot be less than 1'
	 GO TO 10
      END IF
      IF (accfac .ge. 2) THEN
	 print *, ' The acceleration factor cannot be 2 or greater.'
	 GO TO 10
      END IF
      END
      SUBROUTINE rdconv                                                      
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
10    continue
      print *, ' Enter the convergence factor'
      call rdreal (cnvrg)
      IF (cnvrg .lt. 0) THEN
	 print *, ' The convergence factor cannot be negative.'
	 GO TO 10
      END IF
      END
      SUBROUTINE rdshp                                                       
      intrinsic mod
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      character ch
      print *, ' ENTER'
      print *, ' <S> for a square pipe/rod.'
      print *, ' <C> for a round(circular) pipe/rod.'
      print *, ' <R> for a rectangular pipe/rod.'
10    continue
      call rdchar (ch)
      IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
	 shape = square
	 inshp = shape
	 vsize = size
	 call gtisze
      ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
	 shape = circle
	 inshp = shape
	 vsize = size
	 call gtisze
      ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
	 shape  = rctngl
	 inshp  = shape
	 vsize  = .6 * size
      IF (mod(vsize,2) .eq. 0) vsize = vsize + 1
	 call gtisze
      ELSE
	 call wrong
	 GO TO 10
      END IF
      END
      SUBROUTINE rdishp
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      character ch
      IF (solid .eqv. .TRUE.) THEN
	 call wrong
	 print *,' An internal shape does not exist in a rod.'
	 print *,' ''Solid'' must be set to hollow.'
	 return
      END IF
      print *, ' ENTER'
      print *, ' <S> for a square core.'
      print *, ' <C> for a round(circular) core.'
      print *, ' <R> for a rectangular core.'
10    continue
      call rdchar (ch)
      IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
	 inshp = square
	 ivsize = insize
      ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
	 inshp = circle
	 ivsize = insize
      ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
	 inshp = rctngl
	 call rdisze
      ELSE
	 call wrong
	 GO TO 10
      END IF
      END

      SUBROUTINE rdthck                                                      
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      logical answer
      
10    continue
      IF (solid .eqv. .TRUE.) THEN
	 call wrong
	 print *,' Wall thickness is predetermined in a rod.'
	 print *,' ''Solid'' must be set to hollow.'
	 return
      END IF
      print *, ' Enter the thickness of the left side'
      print *, ' Must be an integer > 2 and < ',size-insize+1
      call rdint (hthick)
      call tstsze(hthick,3,size-insize,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 GO TO 10
      END IF
20    continue
      print *, ' Enter the thickness of the top edge'
      print *, ' Must be an integer > 2 and < ',size-ivsize+1
      call rdint (vthick)
      call tstsze(vthick,3,vsize-ivsize,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 call tryopt (answer)
	 IF (answer .eqv. .FALSE.) return
	 GO TO 20
      END IF
      call tstskw
      END

      SUBROUTINE rdsold                                                      
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      
      call solopt(solid)
      call gtisze
      END

      SUBROUTINE rdsize                                                 
      intrinsic mod
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

10    continue
      print *, ' Enter the external diameter or the '
      print *, ' horizontal size (width) of the pipe/rod.'
      print *, ' The size must be an ODD integer from > 2 and < 80'
      call rdint (size)
      IF ((size .ge. 80) .or. (size .le. 2)) THEN
	 call wrong
	 GO TO 10
      END IF
      IF (mod(size,2) .eq. 0) THEN
	 call wrong
	 GO TO 10                                                                       
      END IF
      IF (shape .eq. rctngl) THEN
20       continue
	 print *, ' Enter the vertical size (height)'
	 print *, ' It must be an integer > 2 and < 80.'
	 call rdint (vsize)
	 IF ((size .ge. 80) .or. (size .le. 2)) THEN
	    call wrong
	    GO TO 20
	 END IF
      ELSE     
	 vsize = size
      END IF
      call gtisze
      END

      SUBROUTINE rdisze
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      logical answer
      
10    continue
      IF (solid .eqv. .TRUE.) THEN
	 call wrong
	 print *,' An internal size does not exist in a rod.'
	 print *,' ''Solid'' must be set to hollow.'
	 return
      END IF
      GO TO (20,30,40) inshp
      print *, ' Internal shape value = ',inshp
20    continue
      print *, ' Enter the length of a side (width or height)'
      print *, ' The size must be an integer > 2 and < ',size-4
      call rdint (insize)
      call tstsze(insize,1,size-4,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 GO TO 20
      END IF
      ivsize = insize
      GO TO 90
30    continue
      print *, ' Enter the size (diameter) of the hole including '
      print *, ' the internal core edges'
      print *, ' The size must be an number > 2 and < ',size-4
      call rdint (insize)
      call tstsze(insize,1,size-4,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 GO TO 30
      END IF
      ivsize = insize
      GO TO 90
40    continue
      print *, ' Enter the horizontal length'
      call rdint (insize)
      call tstsze(insize,1,size-4,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 GO TO 40
      END IF
50    continue
      print *, ' Enter the vertical length (height)'
      print *, ' The size must be an number > 2 and < ',vsize-4
      call rdint (ivsize)
      call tstsze(ivsize,3,vsize-4,answer)
      IF (answer .eqv. .FALSE.) THEN
	 call wrong
	 GO TO 50
      END IF
90    continue
      call gtthck
      END

      SUBROUTINE rdrwcl (n,rowcol,begend,size)
      integer n, rowcol, begend, size
      character*6 rc
      character*9 be

      IF (begend .eq. 1) THEN
	 be = 'beginning'
      ELSE
	 be = 'ending   '
      END IF
      IF (rowcol .eq. 1) THEN
	 rc = 'row   '
      ELSE
	 rc = 'column'
      END IF
20    continue
      print *, 'Enter ',be,' ',rc
      call rdint (n)
      IF ((n .lt. 1) .or. (n .gt. size)) THEN
	 print *,' Values must be greater than 1 and less than',size
	 GO TO 20
      END IF
      END 

      SUBROUTINE rdlist 
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      logical answer
      real value
      integer row,col

      return
      call lstopt (answer)
      IF (answer .eqv. .FALSE.) return
      call OpDskI 
      IF (opened .eqv. .FALSE.) return
      call initmp
* Read numerical values from disk
30       continue
	 read (iolog, '(I3,I3,f11.5)', END = 40) row, col, value
	 temper(row,col) = value
	 GO TO 30
40    continue
      call cldisk
      print *, ' W A R N I N G.  If you try to graph this data you'
      print *, ' may get funny looking results.  (If you must fudge,'
      print *, ' first run a simple problem of the same shapes,sizes'
      print *, ' temperatures etc. as the one you are reading.  You'
      print *, ' can set the number of iterations to zero.)'
      END

      SUBROUTINE wrltrs(letter,maxt,mint,tincr)
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      integer i
      character*1 letter(1:17)
      real maxt, mint, temp, tincr, incr

      call clrscr
      IF (finis .eqv. .TRUE.) THEN
	 call wcvrg
      ELSE
	 call wncvrg
      END IF
      call wuppr
      call wintr
      call wlowr
      print *, ' RANGE OF TEMPERATURES'
      temp = mint
      incr = tincr
      do 20 i = 1,16
	 call wrltr(letter,temp,incr,i)
20    continue
      incr = maxt - temp
      call wrltr(letter,temp,incr,17)
      IF (scrnop .eqv. .TRUE.) call prentr
      END

      SUBROUTINE wrltr(letter,temp1,incr,i)
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      real temp1, temp2, incr
      character*1 ch
      character*1 letter(1:17)

      ch = letter(i)
      temp2 = temp1 + incr
      IF (scrnop .eqv. .TRUE.) 
     +   print 100, ch,' ranges from ',temp1,' to ',temp2,' degrees.'
      IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.))
     +   write (iolog,100) ch,' ranges from ',temp1,' to ',temp2,
     +   ' degrees.'
      temp1 = temp2
100   FORMAT (1x,a1,a13,f11.5,a4,f11.5,a1)
      END

      SUBROUTINE beep(n)
      intrinsic char
      integer i,n
      character*1 lebeep
      lebeep = char(7)
      do 10 i = 1,n
	 print *,lebeep
10    continue
      END

      SUBROUTINE wrbas
      print *, ' BASIC PARAMETERS'
      call wshape
      call wsolid
      call wuppr
      call wintr
      call wlowr
      call wprcnt
      END

      SUBROUTINE writer
      print *, ' ITERATION PARAMETERS'
      call wmaxit
      call waccf
      call wconv
      END

      SUBROUTINE wrshp
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

      print *, ' SHAPE PARAMETERS'
      call wshape
      call wsize
      call wsolid
      IF (solid .eqv. .TRUE.) return
      call wishpe
      call wisize
      call wskew
      call wthick
      END

      SUBROUTINE wshape
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

      
      GO TO (10,20,30) shape
10    continue
      print *, ' The External Shape = Square'
      GO TO 90
20    continue
      print *, ' The External Shape = Round'
      GO TO 90
30    continue
      print *, ' The External Shape = Rectangular'
      GO TO 90
90    continue
      END

      SUBROUTINE wishpe
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

      IF (solid .eqv. .TRUE.) GO TO 90
      print *, ' The Internal '
      GO TO (10,20,30) inshp
10    continue
      print *, ' The Internal Shape = Square'
      GO TO 90
20    continue
      print *, ' The Internal Shape = Round'
      GO TO 90
30    continue
      print *, ' The Internal Shape = Rectangular'
      GO TO 90
90    continue
      END

      SUBROUTINE wsolid
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

      IF (solid .eqv. .TRUE.) THEN
	 print *, ' The core of the shield = Solid'
      ELSE
	 print *, ' The core of the shield = Hollow'      
      END IF   
      END

      SUBROUTINE wintr
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      print *, ' Internal temperature = ',intrnt
      END
      SUBROUTINE wuppr
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      print *, ' Upper    temperature = ',uppert
      END
      SUBROUTINE wlowr
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      print *, ' Lower    temperature = ',lowert
      END
      SUBROUTINE wprcnt
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      print *, ' Amount of pipe/rod that is buried/immersed = ',prcnt
      END
      SUBROUTINE wmaxit
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      print *, ' The number of iterations in one pass = ',maxit
      END
      SUBROUTINE waccf
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      print *, ' The acceration factor = ',accfac
      END
      SUBROUTINE wconv
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      print *, ' The convergence criterion is ',cnvrg,' degrees.'
      END

      SUBROUTINE wsize
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
	 print *, ' The external horizontal size = ',size
	 call wvsize
      END
      SUBROUTINE wvsize
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      print *, ' The external vertical   size = ',vsize
      END

      SUBROUTINE wisize
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      print *, ' The internal horizontal size = ',insize
      call wivsze
      END
      SUBROUTINE wivsze
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      print *, ' The internal vertical   size = ',ivsize
      END

      SUBROUTINE wskew
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      IF (solid .eqv. .TRUE.) return
      IF (skewed .eqv. .TRUE.) THEN
	 print *,' The internal core is not centered horizontally.'
      ELSE
	 print *,' The internal core is centered horizontally.'
      END IF
      END

      SUBROUTINE wthick
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      print *, ' The left side horizontal thickness = ',hthick
      call wvthck
      END
      SUBROUTINE wvthck
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      print *, ' The top       vertical   thickness = ',vthick
      END
       
      SUBROUTINE wcvrg
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      print *, ' With convergence value = ', cnvrg,' convergence' 
      print *, ' was achieved in ', iterno,' iterations.'
      IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
	 write(iolog,*) ' With convergence value = ', cnvrg,
     +   ' convergence'
	 write (iolog,*) ' was achieved in ', iterno,' iterations.'
      END IF
      END
      SUBROUTINE wncvrg
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      print *, ' No convergence yet in ', iterno, ' iterations.'
      print *, ' Current convergence is ', bigres, ' degrees.'
      print *, ' Convergence goal is ',cnvrg,' degrees.'
      IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
	 write (iolog,*) ' No convergence yet in ', iterno, 
     +   ' iterations.'
	 write (iolog,*) ' Current convergence is ', bigres, 
     +   ' degrees.'
	 write (iolog,*) ' Convergence goal is ',cnvrg,' degrees.'
      END IF
      END
      
      SUBROUTINE wdivrg (row,col,tempt)
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real    intrnt, lowert, uppert, prcnt, mint, maxt
      integer row,col
      real tempt

      call clrscr
      print *,' Solution is diverging.  Check problem setup.'
      print *,' If necessary modify the acceleration factor'
      print *,' and/or the convergence criterion.'
      print *,' Maximum  temperature = ',maxt
      print *,' Minimum  temperature = ',mint
      print *,' Computed temperature = ',tempt
      print *,' Row = ',row,'  Column = ',col
      print *,' Iteration number = ',interno
      call beep(4)
      call prentr
      END

      SUBROUTINE wrtmsh
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer i
      do 10 i = 1,vsize
	 print *,' ',i,
     +           ' ',tmpshp(i,1),' ',tmpshp(i,2),' ',tmpshp(i,3),
     +           ' ',tmpshp(i,4),' ',tmpshp(i,5),' ',tmpshp(i,6),
     +           ' ',tmpshp(i,7),' ',tmpshp(i,8)
10    continue
      END

      SUBROUTINE wrong
      print *, ' You entered and invalid option or value.'
      call prentr
      END

      SUBROUTINE initar
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer i,j
      character blank
      data blank /' '/

      return
      ENTRY initln                                                      
      do 10 i = 1,79
	 line(i) = blank
10    continue
      return
      ENTRY initts                                                      
      DO 20 j = 1,8
      DO 15 i = 1,79
	 tmpshp(i,j) = 0
15    continue
20    continue
      return
      ENTRY initmp                                                      
      DO 30 i = 1,79
      DO 25 j = 1,79
	 temper(i,j) = 0
25    continue
30    continue
      return
      END
 
      SUBROUTINE init
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real    temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      
      square = 1
      circle = 2
      rctngl = 3
      els    = 1
      wlb    = 2
      wle    = 3
      ils    = 4
      irs    = 5
      wrb    = 6
      wre    = 7
      ers    = 8
      END

      SUBROUTINE initlt(letter)
      character*1 letter(1:17)
      letter(1)  = 'A'
      letter(2)  = 'B'
      letter(3)  = 'C'
      letter(4)  = 'D'
      letter(5)  = 'E'
      letter(6)  = 'F'
      letter(7)  = 'G'
      letter(8)  = 'H'
      letter(9)  = 'I'
      letter(10) = 'J'
      letter(11) = 'K'
      letter(12) = 'L'
      letter(13) = 'M'
      letter(14) = 'N'
      letter(15) = 'O'
      letter(16) = 'P'
      letter(17) = 'Q'
      END
      
      SUBROUTINE initsl
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
	 real intrnt, lowert, uppert, prcnt, mint, maxt
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      
      return
      ENTRY initio
      iolog  = 20
      lincnt = 0
      scrnop = .TRUE.
      diskop = .FALSE.
      ltrltr = .FALSE.
      return
*     Initialize Basic Parameters
      ENTRY initbs
      uppert = 150
      intrnt = -350
      lowert = 3600
      prcnt  = 1
      return
      ENTRY initit
      maxit  = 200
      accfac = 1.84
      cnvrg  = 10
      finis = .TRUE.
      return
      ENTRY initsh
      shape  = rctngl
      size   = 79
      vsize  = 51
      thick  = 29
      inshp  = square
      insize = 23
      ivsize = insize
      hthick = 29
      vthick = 15
      solid  = .FALSE.
      skewed = .FALSE.
      return
      END

      SUBROUTINE initlm(rowb,colb,rowe,cole)
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      integer rowb,colb,rowe,cole
      rowb = 1
      colb = 1
      rowe = vsize
      cole = size
      END

      SUBROUTINE tstskw 
      intrinsic mod
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer x

      IF (solid .eqv. .TRUE.) THEN
	 skewed = .FALSE.
	 return
      END IF
      x = size-(insize-2)
      skewed = .TRUE.
      IF (mod(x,2) .ne. 0) return
      x = x/2
      IF (hthick .eq. x) skewed = .FALSE.
      END

      SUBROUTINE tstrc (n1,n2,rowcol,answer)
      integer n1,n2,rowcol
      logical answer
      character*6 rc

      IF (rowcol .eq. 1) THEN
	 rc = 'row '
      ELSE
	 rc = 'column '
      END IF
      answer = .TRUE.
      IF (n1 .gt. n2) THEN
	 print *, ' The beginning ', rc, n1, 
     +   ' is greater than the ending  ', rc, n2
	 answer = .FALSE.
      END IF 
      END

      SUBROUTINE tstsze (val1,val2,val3,answer)
      integer val1,val2,val3
      logical answer
      answer = .TRUE.
      IF ((val1 .lt. val2) .or. (val1 .gt. val3)) answer = .FALSE.
      END

      SUBROUTINE inwall(row,col,answer)
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,col
      logical answer

      IF ((row .le. 1) .or. (row .ge. vsize)) 
     +   GO TO 90
      IF (tmpshp(row,wlb) .le. 0)
     +   GO TO 90
      IF ((col .lt. tmpshp(row,wlb)) .or. (col .gt. tmpshp(row,wre)))
     +   GO TO 90
      IF (solid .eqv. .TRUE.) 
     +   GO TO 95
      IF (((row .ge. vthick) .and. (row .le. vthick+ivsize-1)) .and.
     +   ((col .ge. tmpshp(row,ils)) .and. (col .le. tmpshp(row,irs))))
     +   GO TO 90
      GO TO 95
90    continue
      answer = .FALSE.
      return
95    continue
      answer = .TRUE.
      return
      END

      SUBROUTINE onwall(row,col,answer)
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,col
      logical answer

      IF ((row .lt. 1) .or. (row .gt. vsize))
     +   GO TO 90
      IF ((col .lt. 1) .or. (col .gt. size))
     +   GO TO 90
      IF (solid .eqv. .TRUE.) GO TO 95
      IF (((row .gt. vthick) .and. (row .lt. vthick+ivsize-1)) .and.
     +   ((col .gt. tmpshp(row,ils)) .and. (col .lt. tmpshp(row,irs))))
     +   GO TO 90
      GO TO 95
90    continue
      answer = .FALSE.
      return
95    continue
      answer = .TRUE.
      return
      END

      SUBROUTINE gtbas
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      integer option
      logical answer

      call basopt(answer)
      IF (answer .eqv. .FALSE.) return
5     continue
      call clrscr
      call wrbas
      print *, ' ENTER'
      print *, ' 1  To accept all variables'
      print *, ' 2  To reinitialize all basic variables'
      print *, ' 3  To change all variables'
      print *, ' 4  To change external and internal shield shapes'
      print *, ' 5  To change Top Edge    temperature'
      print *, ' 6  To change Internal    temperature'
      print *, ' 7  To change Bottom Edge temperature'
      print *, ' 8  To change Percent of Shield at Bottom Temperature'
      print *, ' 9  To change Solid Option'
      call rdint (Option)
      GO TO (90,10,15,20,25,30,35,40,45) Option
      call wrong
      GO TO 5
10    continue
      call initbs
      GO TO 5
15    continue
      call rdshp
      call rduppr
      call rdintr
      call rdlowr
      call rdpct
      call rdsold
      GO TO 5
20    call rdshp
      GO TO 5
25    call rduppr
      GO TO 5
30    call rdintr
      GO TO 5
35    call rdlowr
      GO TO 5
40    call rdpct
      GO TO 5
45    call rdsold
      GO TO 5
90    continue
      inshp = shape
      END

      SUBROUTINE gtiter
      common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
	 integer maxit, iterno
	 real    accfac, cnvrg, bigres
	 logical finis,divrg
      integer option
      logical answer

      call itropt (answer)
      IF (answer .eqv. .FALSE.) return
10    continue
      call clrscr
      call writer
      print *, ' ENTER'
      print *, ' 1  To accept all variables'
      print *, ' 2  To reinitialize all iteration variables'
      print *, ' 3  To change all variables'
      print *, ' 4  To change number of iterations'
      print *, ' 5  To change the acceleration factor'
      print *, ' 6  To change the convergence factor'
      call rdint (Option)
      GO TO (90,20,30,40,50,60) option
      call wrong
      GO TO 10
20    continue
      call initit
      GO TO 10
30    continue
      call rdmxt
      call rdaccf
      call rdconv
      GO TO 10
40    continue
      call rdmxt
      GO TO 10
50    continue
      call rdaccf
      GO TO 10
60    continue
      call rdconv
      GO TO 10
90    continue
      END

      SUBROUTINE gtshp
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      integer option
      logical answer

      call shpopt (answer)
      IF (answer .eqv. .FALSE.) return
10    continue
      call clrscr
      call wrshp
      print *, ' ENTER'
      print *, ' 1  To accept all variables'
      print *, ' 2  To reinitialize all shape variables'
      print *, ' 3  To change all variables'
      print *, ' 4  To change external shield shape'
      print *, ' 5  To change external shield size'
      print *, ' 6  To change internal core shape'
      print *, ' 7  To change internal core size'
      print *, ' 8  To change shield wall thickness'
      print *, ' 9  To change solid option'
      call rdint (Option)
      GO TO (90,15,20,25,30,35,40,50,60) option
      call wrong
      GO TO 10
15    continue
      call initsh
      GO TO 10
20    continue
      call rdshp
      call rdsize
      call rdishp
      call rdisze
      call rdthck
      call rdsold
      GO TO 10
25    continue
      call rdshp
      GO TO 10
30    continue
      call rdsize
      GO TO 10
35    continue
      call rdishp
      GO TO 10
40    continue
      call rdisze
      GO TO 10
50    continue
      call rdthck
      GO TO 10
60    continue
      call rdsold
      GO TO 10
90    continue
      IF ((insize .eq. 0) .or. (ivsize .eq. 0)) solid = .TRUE.
      END

      SUBROUTINE gtisze
      intrinsic mod
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

	 IF (solid .eqv. .TRUE.) THEN
	    insize = 0
	    ivsize = 0
	 ELSE
	    insize = .4 * size
	    IF (mod(insize,2) .eq. 0) insize = insize + 1
	    ivsize = .4 * vsize
	    IF (mod(ivsize,2) .eq. 0) ivsize = ivsize + 1
	 END IF
	 call gtthck
      END

      SUBROUTINE gtthck
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed

	 IF (solid .eqv. .TRUE.) THEN
	    hthick = size
	    vthick = vsize
	 ELSE
	    hthick = ( size - (insize - 2))/2
	    vthick = (vsize - (ivsize - 2))/2
	 END IF
	 END

      SUBROUTINE gtioop (answer)
      common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
	 integer   iolog,lincnt
	 logical   scrnop,diskop,opened,ltrltr
	 character line(1:79)
      logical answer,ans
						 
10    continue
      call scropt(scrnop)
      call dskopt(diskop)
      IF (diskop .eqv. .TRUE.) call OpDskO
      IF ((opened .eqv. .FALSE.) .and. (scrnop .eqv. .FALSE.)) THEN
	 print *, ' No device available for output'
	 call tryopt (ans)
	 IF (ans .eqv. .TRUE.) GO TO 10
	 answer = .FALSE.
      ELSE
	 answer = .TRUE.
      END IF
      END 

      SUBROUTINE gtindx(row, collb, colle, colrb, colre, pieces)
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,colrb,colre,collb,colle,pieces
				  
      IF (tmpshp(row,ils) .eq. 0) THEN
	 collb  = tmpshp(row,wlb)
	 colle  = tmpshp(row,wre)
	 colrb  = 0
	 colre  = 0
	 pieces = 1
	 return
      ELSE
	 collb  = tmpshp(row,wlb)
	 colle  = tmpshp(row,wle)
	 colrb  = tmpshp(row,wrb)
	 colre  = tmpshp(row,wre)
	 pieces = 2
      END IF
      END

      SUBROUTINE gtlmts(rowb,colb,rowe,cole)
      logical answer
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      integer rowb,colb,rowe,cole,option,r,c,b,e
      data r/1/,c/2/,b/1/,e/2/

20    continue
      call initlm (rowb,colb,rowe,cole)
      GO TO 80
30    continue
      call rdrwcl (rowb,r,b,size)
      call rdrwcl (colb,c,b,vsize)
      call rdrwcl (rowe,r,e,size)
      call rdrwcl (cole,c,e,vsize)
      GO TO 80
40    continue
      call rdrwcl (rowb,r,b,size)
      GO TO 80
50    continue
      call rdrwcl (colb,c,b,vsize)
      GO TO 80
60    continue
      call rdrwcl (rowe,r,e,size)
      GO TO 80
70    continue
      call rdrwcl (cole,c,e,vsize)
      GO TO 80
80    continue
      call clrscr
      print *, ' Beginning row    = ', rowb
      print *, ' Beginning column = ', colb
      print *, ' Ending row       = ', rowe
      print *, ' Ending column    = ', cole
      print *
      call tstrc (rowb,rowe,r,answer)
      IF (answer .eqv. .FALSE.) GO TO 30
      call tstrc (colb,cole,c,answer)
      IF (answer .eqv. .FALSE.) GO TO 30
      print *, ' ENTER'
      print *, ' 1  To accept all values.'
      print *, ' 2  To change all values.'
      print *, ' 3  To change beginning row.'
      print *, ' 4  To change beginning column.'
      print *, ' 5  To change ending row.'
      print *, ' 6  To change ending column.'
      call rdint (Option)
      GO TO (90,30,40,50,60,70) option
      call wrong
      GO TO 80
90    continue
      END

      SUBROUTINE mkrnd (a,b,d,i,j)
      intrinsic abs, sqrt, nint, real
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,rowb,row2,rowe,col,colm,a,b,d,i,j,x,xc,cola
      real r,y

      rowb = b 
      rowe = b + (d-1)/2
      xc   = a + (d-1)/2
      r    = rowe-rowb
      row2 = rowb + (r + 1)/2
      cola = 0
      do 30 row = rowb+1,rowe-1
	 y = rowe - row
	 x = nint(sqrt(r*r-y*y))
	 col  = xc-x
	 colm = size-col+1
	 tmpshp(row,        i) = col
	 tmpshp(vsize-row+1,i) = col
	 tmpshp(row,        j) = colm
	 tmpshp(vsize-row+1,j) = colm
	 IF (col .eq. a) cola = cola + 1
30    continue
      tmpshp(rowe,i) = a
      tmpshp(rowe,j) = size-a+1
      cola = cola + 1  
      col  = xc - cola
      colm = size-col+1
      tmpshp(rowb,        i) = col
      tmpshp(vsize-rowb+1,i) = col
      tmpshp(rowb,        j) = colm
      tmpshp(vsize-rowb+1,j) = colm
      END

      SUBROUTINE mkrect (a,b,hs,vs,i,j)
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,a,b,hs,vs,i,j

      do 40 row = b,b+vs-1
	 tmpshp(row,i) = a
	 tmpshp(row,j) = a+hs-1
40    continue
      END

      SUBROUTINE mkwall
      intrinsic abs
      common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
	 integer shape,size,vsize,inshp,insize,ivsize,
     +       thick,hthick,vthick,square,circle,rctngl
	 logical solid, skewed
      common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
	 real temper (1:79,1:79)
	 integer tmpshp(1:79,1:8)
	 integer els,wlb,wle,ils,irs,wrb,wre,ers
      integer row,midrow,diff

      midrow = (vsize+1)/2
      do 50 row = 2, vsize-1
	 diff = tmpshp(row,els)-tmpshp(row-1,els)
	 IF (diff)10,20,30
10       continue
	    tmpshp(row,wlb) = tmpshp(row-1,els)
	    tmpshp(row,wre) = tmpshp(row-1,ers)
	    GO TO 40
20       continue
	    tmpshp(row,wlb) = tmpshp(row,els)+1
	    tmpshp(row,wre) = tmpshp(row,ers)-1
	    GO TO 40
30       continue
	    tmpshp(row,wlb) = tmpshp(row+1,els)
	    tmpshp(row,wre) = tmpshp(row+1,ers)
	    GO TO 40
40       continue
	 IF (tmpshp(row,ils) .eq. 0) THEN
	    tmpshp(row,irs) = 0
	    tmpshp(row,wle) = 0
	    tmpshp(row,wrb) = 0
	 ELSE
	    tmpshp(row,wle) = tmpshp(row,ils)-1
	    tmpshp(row,wrb) = tmpshp(row,irs)+1
	 END IF
50    continue
      END                    

      SUBROUTINE NOP
      END

      SUBROUTINE ClrScr
      write (*,10) '1'
10    format (a1)
*      print '(''1'')'
      END

      SUBROUTINE PrEntr
      Print *, 'Press Enter to Continue'
      Read *
      END

